home *** CD-ROM | disk | FTP | other *** search
/ CAD Tools / CAD Tools.iso / programs / cad010.exe / ACADWIN3.EXE / SAMPLE / ATTREDEF.LSP next >
Lisp/Scheme  |  1994-03-08  |  12KB  |  337 lines
  1. ;;;--------------------------------------------------------------------------;
  2. ;;; ATTREDEF.LSP
  3. ;;;   (C) Copyright 1988-1994 by Autodesk, Inc.
  4. ;;;  
  5. ;;;   This program is copyrighted by Autodesk, Inc. and is  licensed
  6. ;;;   to you under the following conditions.  You may not distribute
  7. ;;;   or  publish the source code of this program in any form.   You
  8. ;;;   may  incorporate this code in object form in derivative  works
  9. ;;;   provided  such  derivative  works  are  (i.) are  designed and
  10. ;;;   intended  to  work  solely  with  Autodesk, Inc. products, and
  11. ;;;   (ii.)  contain  Autodesk's  copyright  notice  "(C)  Copyright
  12. ;;;   1988-1994 by Autodesk, Inc."
  13. ;;;
  14. ;;;   AUTODESK  PROVIDES THIS PROGRAM "AS IS" AND WITH  ALL  FAULTS.
  15. ;;;   AUTODESK  SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF  MER-
  16. ;;;   CHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK,  INC.
  17. ;;;   DOES  NOT  WARRANT THAT THE OPERATION OF THE PROGRAM  WILL  BE
  18. ;;;   UNINTERRUPTED OR ERROR FREE.
  19. ;;; --------------------------------------------------------------------------;
  20. ;;; DESCRIPTION
  21. ;;;
  22. ;;;   This program allows you to redefine a Block and update the
  23. ;;;   Attributes associated with any previous insertions of that Block.
  24. ;;;   All new Attributes are added to the old Blocks and given their
  25. ;;;   default values. All old Attributes with equal tag values to the new
  26. ;;;   Attributes are redefined but retain their old value. And all old
  27. ;;;   Attributes not included in the new Block are deleted.
  28. ;;;
  29. ;;;   Note that if handles are enabled, new handles will be assigned to
  30. ;;;   each redefined block.
  31. ;;;
  32. ;;; --------------------------------------------------------------------------;
  33.  
  34. ;;;
  35. ;;; Oldatts sets "old_al" (OLD_Attribute_List) to the list of old Attributes
  36. ;;; for each Block.  The list does not include constant Attributes.
  37. ;;;
  38. (defun oldatts (/ e_name e_list cont)
  39.   (setq oa_ctr 0 
  40.         cont   T
  41.         e_name b1
  42.   )
  43.   (while cont
  44.     (if (setq e_name (entnext e_name))
  45.       (progn
  46.         (setq e_list (entget e_name))
  47.         (if (and (= (cdr (assoc 0 e_list)) "ATTRIB")
  48.                  ;; NOT a constant attribute -- (cdr (assoc 70 e_list)) != 2)
  49.                  (/= (logand (cdr (assoc 70 e_list)) 2) 2))
  50.           (progn
  51.             (if old_al
  52.               (setq old_al (cons e_list old_al))
  53.               (setq old_al (list e_list))
  54.             )
  55.             (setq oa_ctr (1+ oa_ctr))           ; count the number of old atts
  56.           )
  57.           ;; else, exit
  58.           (setq cont nil)
  59.         )
  60.       )
  61.       (setq cont nil)
  62.     )
  63.   )
  64. )
  65. ;;;
  66. ;;; Newatts sets "new_al" to the list of new Attributes in the new Block.
  67. ;;; The list does not include constant Attributes.
  68. ;;;
  69. (defun newatts (ssetn ssl / i e_name e_list)
  70.   (setq i 0 na_ctr 0)
  71.   (while (< i ssl)
  72.     (if (setq e_name (ssname ssetn i))
  73.       (progn
  74.         (setq e_list (entget e_name))
  75.         (if (and (= (cdr (assoc 0 e_list)) "ATTDEF")
  76.                  ;; NOT a constant attribute -- (cdr (assoc 70 e_list)) != 2)
  77.                  (/= (logand (cdr (assoc 70 e_list)) 2) 2))
  78.           (progn
  79.             (if new_al
  80.               (setq new_al (cons e_list new_al))
  81.               (setq new_al (list e_list))
  82.             )
  83.             (setq na_ctr (1+ na_ctr))     ; count the number of new atts
  84.           )
  85.         )
  86.       )
  87.     )
  88.     (setq i (1+ i))
  89.   )
  90.   na_ctr
  91. )
  92. ;;;
  93. ;;; Compare the list of "old" to the list of "new" Attributes and make
  94. ;;; the two lists "same" and "preset". "Same" contains the old values of
  95. ;;; all the Attributes in "old" with equal tag values to some Attribute
  96. ;;; in "new" and the default values of all the other Attributes. "Preset"
  97. ;;; contains the preset Attributes in old with equal tag values to some
  98. ;;; Attribute in new.
  99. ;;;
  100. (defun compare (/ i j)
  101.   (setq i 0
  102.         j 0
  103.         pa_ctr 0
  104.         same nil
  105.         va_ctr 0
  106.         preset nil)
  107.   ;; "i" is a counter that increments until the number of new attributes
  108.   ;; is reached.
  109.   (while (< i na_ctr)
  110.     (cond 
  111.       ;; If there are old attributes AND the tag strings of the old and new 
  112.       ;; attributes are the same...
  113.       ((and old_al
  114.             (= (cdr (assoc 2 (nth j old_al))) (cdr (assoc 2 (nth i new_al)))))
  115.         ;; IS a preset attribute -- (cdr (assoc 70 e_list)) == 8)
  116.         (if (= (logand (cdr (assoc 70 (nth i new_al))) 8) 8)
  117.           ;; If the attribute is a preset attribute then add it to the list
  118.           ;; of preset attributes and increment the counter "pa_ctr".
  119.           ;; IS a preset attribute -- (cdr (assoc 70 e_list)) == 8)
  120.           (progn
  121.             (if preset
  122.               (setq preset (cons (nth j old_al) preset))
  123.               (setq preset (list (nth j old_al)))
  124.             )
  125.             (setq pa_ctr (1+ pa_ctr))     ; count preset atts
  126.           )
  127.           ;; Else, add it to the list of same attributes "same".
  128.           (if same
  129.             (setq same (cons (cdr (assoc 1 (nth j old_al))) same))
  130.             (setq same (list (cdr (assoc 1 (nth j old_al)))))
  131.           )
  132.         )
  133.         ;; If the attribute must be verified, increment counter "va_ctr".
  134.         ;; NOT a preset attribute -- (cdr (assoc 70 e_list)) != 8)
  135.         (if (and (/= (logand (cdr (assoc 70 (nth i new_al))) 8) 8)
  136.                  ;; IS a verified attribute -- (cdr (assoc 70 e_list)) == 4)
  137.                  (= (logand (cdr (assoc 70 (nth i new_al))) 4) 4))
  138.           (setq va_ctr (+ 1 va_ctr))
  139.         )
  140.         (setq i (1+ i))
  141.         (setq j 0)
  142.       )
  143.       ;; If the number of old attributes equals the old attribute counter "j"
  144.       ((= j oa_ctr)
  145.         ;; If this attribute is not a preset attribute, but is not in the 
  146.         ;; old list, then add it to the list "same".
  147.         ;; NOT a preset attribute -- (cdr (assoc 70 e_list)) != 8)
  148.         (if (/= (logand (cdr (assoc 70 (nth i new_al))) 8) 8)
  149.           (if same
  150.             (setq same (cons (cdr (assoc 1 (nth i new_al))) same))
  151.             (setq same (list (cdr (assoc 1 (nth i new_al)))))
  152.           )
  153.         )
  154.         ;; NOT a preset attribute -- (cdr (assoc 70 e_list)) != 8)
  155.         (if (and (/= (logand (cdr (assoc 70 (nth i new_al))) 8) 8)
  156.                  ;; IS a verified attribute -- (cdr (assoc 70 e_list)) == 4)
  157.                  (= (logand (cdr (assoc 70 (nth i new_al))) 4) 4))
  158.           (setq va_ctr (+ 1 va_ctr))
  159.         )
  160.         (setq i (1+ i))
  161.         (setq j 0)
  162.       )
  163.       ;; Increment the old attribute counter "j"...
  164.       (t
  165.         (setq j (1+ j))
  166.       )
  167.     )
  168.   )
  169. )
  170. ;;;
  171. ;;; Find the entity for each of the "preset" Attributes in the newly
  172. ;;; inserted Block.
  173. ;;;
  174. (defun findpt ()
  175.   (setq test T)
  176.   (setq en (entnext e1))
  177.   (setq e_list (entget en))
  178.   (while test
  179.     (if (and (= (cdr (assoc 0 e_list)) "ATTRIB") (= (cdr (assoc 2 e_list)) tag))
  180.       (setq test nil)
  181.       (progn
  182.         (setq ex en)
  183.         (setq en (entnext ex))
  184.         (if e_list
  185.           (setq e_list (entget en))
  186.         )
  187.       )
  188.     )
  189.   )
  190. )
  191. ;;;
  192. ;;; Insert a new Block on top of each old Block and set its new Attributes
  193. ;;; to their values in the list "same". Then replace each of the "preset"
  194. ;;; Attributes with its old value.
  195. ;;;
  196. (defun redef (/ xsf ysf zsf ls i e1 v)
  197.   (command "_.UCS" "_E" b1)         ; define the block's UCS
  198.   (setq xsf (cdr (assoc 41 (entget b1)))) ; find x scale factor
  199.   (setq ysf (cdr (assoc 42 (entget b1)))) ; find y scale factor
  200.   (setq zsf (cdr (assoc 43 (entget b1)))) ; find z scale factor
  201.   (setq ls (length same))
  202.   (setq i 0)
  203.   (command "_.INSERT" bn "0.0,0.0,0.0" "_XYZ" xsf ysf zsf "0.0")
  204.   (while (< i ls)                     ; set attributes to their values
  205.     (command (nth i same))
  206.     (setq i (1+ i))
  207.   )
  208.   (while (< 0 va_ctr)
  209.     (command "")                      ; at prompts, verify attributes
  210.     (setq va_ctr (1- va_ctr))
  211.   )
  212.   (setq i 0)
  213.   (setq e1 (entlast))
  214.   (while (< 0 pa_ctr)                    ; edit each of the "preset" attributes
  215.     (setq tag (cdr (assoc 2 (nth i preset))))
  216.     (setq v (cdr (assoc 1 (nth i preset))))
  217.     (findpt)